home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / prim / itimer.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  26.0 KB  |  734 lines
  1. ;;; Interval timers for XEmacs
  2. ;;; Copyright (C) 1988, 1991, 1993 Kyle E. Jones
  3. ;;; Modified 5 Feb 91 by Jamie Zawinski <jwz@lucid.com> for Lucid Emacs
  4. ;;; And again, 15 Dec 93.
  5. ;;;
  6. ;; This file is part of XEmacs.
  7.  
  8. ;; XEmacs is free software; you can redistribute it and/or modify it
  9. ;; under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; XEmacs is distributed in the hope that it will be useful, but
  14. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16. ;; General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  20. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21. ;;;
  22. ;;; Send bug reports to kyle@uunet.uu.net.
  23.  
  24. ;; The original v18 version of this file worked by having an external program
  25. ;; wake up once a second to generate an interrupt for emacs; then an emacs
  26. ;; process filter was used to schedule timers. 
  27. ;;
  28. ;; This version works by associating with each timer a "timeout" object,
  29. ;; since the XEmacs/Lucid Emacs event loop has the concept of timers built 
  30. ;; in to it.  There is no single scheduler function; instead, each timer 
  31. ;; re-sets itself as it is invoked.
  32.  
  33. ;; `itimer' feature means Emacs-Lisp programers get:
  34. ;;    itimerp, itimer-value, itimer-restart, itimer-function,
  35. ;;    set-itimer-value, set-itimer-restart, set-itimer-function
  36. ;;    get-itimer, start-itimer, read-itimer, delete-itimer
  37. ;;
  38. ;; Interactive users get these commands:
  39. ;;    edit-itimers, list-itimers, start-itimer
  40. ;;
  41. ;; See the doc strings of these functions for more information.
  42.  
  43. (defvar itimer-version "1.00"
  44.   "Version number of the itimer package.")
  45.  
  46. (defvar itimer-list nil
  47.   "List of all active itimers.")
  48.  
  49. ;; not needed in XEmacs
  50. ;(defvar itimer-process nil
  51. ;  "Process that drives all itimers.")
  52.  
  53. ;; This value is maintained internally; it does not determine itimer
  54. ;; granularity.  Itimer granularity is 1 second, plus delays due to
  55. ;; system and Emacs internal activity that delay dealing with process
  56. ;; output.
  57. ;; not needed in XEmacs
  58. ;(defvar itimer-process-next-wakeup 1
  59. ;  "Itimer process will wakeup to service running itimers within this
  60. ;many seconds.")
  61.  
  62. (defvar itimer-edit-map nil
  63.   "Keymap used when in Itimer Edit mode.")
  64.  
  65. (if itimer-edit-map
  66.     ()
  67.   (setq itimer-edit-map (make-sparse-keymap))
  68.   (define-key itimer-edit-map "s" 'itimer-edit-set-field)
  69.   (define-key itimer-edit-map "d" 'itimer-edit-delete-itimer)
  70.   (define-key itimer-edit-map "q" 'itimer-edit-quit)
  71.   (define-key itimer-edit-map "\t" 'itimer-edit-next-field)
  72.   (define-key itimer-edit-map " " 'next-line)
  73.   (define-key itimer-edit-map "n" 'next-line)
  74.   (define-key itimer-edit-map "p" 'previous-line)
  75.   (define-key itimer-edit-map "\C-?" 'itimer-edit-previous-field)
  76.   (define-key itimer-edit-map "x" 'start-itimer)
  77.   (define-key itimer-edit-map "?" 'itimer-edit-help))
  78.   
  79. (defvar itimer-edit-start-marker nil)
  80.  
  81. ;; macros must come first... or byte-compile'd code will throw back its
  82. ;; head and scream.
  83.  
  84. (defmacro itimer-decf (variable)
  85.   (list 'setq variable (list '1- variable)))
  86.  
  87. (defmacro itimer-incf (variable)
  88.   (list 'setq variable (list '1+ variable)))
  89.  
  90. (defmacro itimer-signum (n)
  91.   (list 'if (list '> n 0) 1
  92.     (list 'if (list 'zerop n) 0 -1)))
  93.  
  94. ;; Itimer access functions should behave as if they were subrs.  These
  95. ;; macros are used to check the arguments to the itimer functions and
  96. ;; signal errors appropriately if the arguments are not valid.
  97.  
  98. (defmacro check-itimer (var)
  99.   "If VAR is not bound to an itimer, signal wrong-type-argument.
  100. This is a macro."
  101.   (list 'setq var
  102.     (list 'if (list 'itimerp var) var
  103.           (list 'signal ''wrong-type-argument
  104.             (list 'list ''itimerp var)))))
  105.  
  106. (defmacro check-itimer-coerce-string (var)
  107.   "If VAR is not bound to a string, look up the itimer that it names and
  108. bind VAR to it.  Otherwise if VAR is not bound to an itimer, signal
  109. wrong-type-argument.  This is a macro."
  110.   (list 'setq var
  111.     (list 'cond
  112.           (list (list 'itimerp var) var)
  113.           (list (list 'stringp var) (list 'get-itimer var))
  114.           (list t (list 'signal ''wrong-type-argument
  115.                 (list 'list ''string-or-itimer-p var))))))
  116.  
  117. (defmacro itimer-check-natnum (var)
  118.   "If VAR is not bound to a non-negative number, signal wrong-type-argument.
  119. This is a macro."
  120.   (list 'setq var
  121.     (list 'if (list 'natnump var) var
  122.           (list 'signal ''wrong-type-argument
  123.             (list 'list ''natnump var)))))
  124.  
  125. (defmacro itimer-check-string (var)
  126.   "If VAR is not bound to a string, signal wrong-type-argument.
  127. This is a macro."
  128.   (list 'setq var
  129.     (list 'if (list 'stringp var) var
  130.           (list 'signal ''wrong-type-argument
  131.             (list 'list ''stringp var)))))
  132.  
  133. ;; Functions to access and modify itimer attributes.
  134.  
  135. (defun itimerp (obj)
  136.   "Returns non-nil iff OBJ is an itimer."
  137.   (and (consp obj) (stringp (car obj)) (eq (length obj)
  138.                        5 ; for XEmacs
  139.                        ;4 ; original version
  140.                        )))
  141.  
  142. (defun itimer-name (itimer)
  143.   "Returns the name of ITIMER."
  144.   (check-itimer itimer)
  145.   (car itimer))
  146.  
  147. (defun itimer-value (itimer)
  148.   "Returns the number of seconds until ITIMER expires."
  149.   (check-itimer itimer)
  150.   (nth 1 itimer))
  151.  
  152. (defun itimer-restart (itimer)
  153.   "Returns the value to which ITIMER will be set at restart.
  154. nil is returned if this itimer doesn't restart."
  155.   (check-itimer itimer)
  156.   (nth 2 itimer))
  157.  
  158. (defun itimer-function (itimer)
  159.   "Returns the function of ITIMER.
  160. This function is called each time ITIMER expires."
  161.   (check-itimer itimer)
  162.   (nth 3 itimer))
  163.  
  164. ;; XEmacs-specific
  165. (defun itimer-id (itimer)
  166.   "Returns the timeout-id of ITIMER."
  167.   (check-itimer itimer)
  168.   (nth 4 itimer))
  169.  
  170. (defun set-itimer-value (itimer value
  171.                 ;; XEmacs doesn't need this
  172.                 ;; &optional nowakeup
  173.                 )
  174.   "Set the timeout value of ITIMER to be VALUE.
  175. Itimer will expire is this many seconds.
  176. Returns VALUE."
  177. ;; Optional third arg NOWAKEUP non-nil means do not wakeup the itimer
  178. ;; process to recompute a correct wakeup time, even if it means this
  179. ;; itimer will expire late.  itimer-process-filter uses this option.
  180. ;; This is not meant for ordinary usage, which is why it is not
  181. ;; mentioned in the doc string.
  182.   (check-itimer itimer)
  183.   (itimer-check-natnum value)
  184.   (let ((inhibit-quit t))
  185.  
  186. ;    ;; If we're allowed to wakeup the itimer process,
  187. ;    ;; and the itimer process's next wakeup needs to be recomputed,
  188. ;    ;; and the itimer is running, then we wakeup the itimer process.
  189. ;    (or (and (not nowakeup) (< value itimer-process-next-wakeup)
  190. ;         (get-itimer (itimer-name itimer))
  191. ;         (progn (itimer-process-wakeup)
  192. ;            (setcar (cdr itimer) value)
  193. ;            (itimer-process-wakeup)))
  194. ;    (setcar (cdr itimer) value))
  195.  
  196.     ;; the XEmacs way:
  197.     (if (itimer-id itimer)
  198.     (deactivate-itimer itimer))
  199.     (setcar (cdr itimer) value)
  200.     (activate-itimer itimer)
  201.  
  202.     value))
  203.  
  204. (defun set-itimer-restart (itimer restart)
  205.   "Set the restart value of ITIMER to be RESTART.
  206. If RESTART is nil, ITIMER will not restart when it expires.
  207. Returns RESTART."
  208.   (check-itimer itimer)
  209.   (if restart (itimer-check-natnum restart))
  210.   (and restart (< restart 1) (signal 'args-out-of-range (list restart)))
  211. ;;  (setcar (cdr (cdr itimer)) restart)
  212.   ;; the XEmacs way
  213.   (let ((was-active (itimer-id itimer))
  214.     (inhibit-quit t))
  215.     (if was-active
  216.     (deactivate-itimer itimer))
  217.     (setcar (cdr (cdr itimer)) restart)
  218.     (if was-active
  219.     (progn
  220.       (setcar (cdr itimer) restart)
  221.       (if restart
  222.           (activate-itimer itimer)))))
  223.   restart)
  224.  
  225. (defun set-itimer-function (itimer function)
  226.   "Set the function of ITIMER to be FUNCTION.
  227. FUNCTION will be called when itimer expires.
  228. Returns FUNCTION."
  229.   (check-itimer itimer)
  230.   (setcar (cdr (cdr (cdr itimer))) function))
  231.  
  232. ;; XEmacs-specific
  233. (defun set-itimer-id (itimer id)
  234.   (check-itimer itimer)
  235.   (setcar (cdr (cdr (cdr (cdr itimer)))) id))
  236.  
  237. (defun get-itimer (name)
  238.   "Return itimer named NAME, or nil if there is none."
  239.   (itimer-check-string name)
  240.   (assoc name itimer-list))
  241.  
  242. (defun read-itimer (prompt &optional initial-input)
  243.   "Read the name of an itimer from the minibuffer and return the itimer
  244. associated with that name.  The user is prompted with PROMPT.
  245. Optional second arg INITIAL-INPUT non-nil is inserted into the
  246.   minibuffer as initial user input."
  247.   (get-itimer (completing-read prompt itimer-list nil 'confirm initial-input)))
  248.  
  249. (defun delete-itimer (itimer)
  250.   "Deletes ITIMER.  ITIMER may be an itimer or the name of one."
  251.   (check-itimer-coerce-string itimer)
  252.   (deactivate-itimer itimer)  ;; for XEmacs
  253.   (setq itimer-list (delq itimer itimer-list)))
  254.  
  255. ;jwz: this is preloaded so don't ;;;###autoload
  256. (defun start-itimer (name function value &optional restart)
  257.   "Start an itimer.
  258. Args are NAME, FUNCTION, VALUE &optional RESTART.
  259. NAME is an identifier for the itimer.  It must be a string.  If an itimer
  260.   already exists with this name, NAME will be modified slightly to until
  261.   it is unique.
  262. FUNCTION should be a function (or symbol naming one) of no arguments.  It
  263.   will be called each time the itimer expires.  The function can access
  264.   itimer that invoked it through the variable `current-itimer'.
  265. VALUE is the number of seconds until this itimer expires.
  266. Optional fourth arg RESTART non-nil means that this itimer should be
  267.   restarted automatically after its function is called.  Normally an itimer
  268.   is deleted at expiration after its function has returned. 
  269.   If non-nil RESTART should be a number indicating the value at which the
  270.   itimer should be set at restart time.
  271. Returns the newly created itimer."
  272.   (interactive
  273.    (list (completing-read "Start itimer: " itimer-list)
  274.      (read (completing-read "Itimer function: " obarray 'fboundp))
  275.      (let (value)
  276.        (while (not (natnump value))
  277.          (setq value (read-from-minibuffer "Itimer value: " nil nil t)))
  278.        value)
  279.      (let ((restart t))
  280.        (while (and restart (not (natnump restart)))
  281.          (setq restart (read-from-minibuffer "Itimer restart: " nil nil t)))
  282.        restart)))
  283.   (itimer-check-string name)
  284.   (itimer-check-natnum value)
  285.   (if restart (itimer-check-natnum restart))
  286.   ;; Make proposed itimer name unique if it's not already.
  287.   (let ((oname name)
  288.     (num 2))
  289.     (while (get-itimer name)
  290.       (setq name (concat oname "<" num ">"))
  291.       (itimer-incf num)))
  292. ;  ;; If there's no itimer process, start one now.
  293. ;  ;; Otherwise wake up the itimer process so that seconds slept before
  294. ;  ;; the new itimer is created won't be counted against it.
  295. ;  (if itimer-process
  296. ;      (itimer-process-wakeup)
  297. ;    (itimer-process-start))
  298.   (let ((inhibit-quit t))
  299.     ;; add the itimer to the global list
  300.     (setq itimer-list
  301.       (cons (list name value restart function nil) ; extra slot for XEmacs
  302.         itimer-list))
  303. ;    ;; If the itimer process is scheduled to wake up too late for the itimer
  304. ;    ;; we wake it up to calculate a correct wakeup value giving consideration
  305. ;    ;; to the newly added itimer.
  306. ;    (if (< value itimer-process-next-wakeup)
  307. ;    (itimer-process-wakeup)))
  308.     ;; for XEmacs
  309.     (activate-itimer (car itimer-list))
  310.     )
  311.   (car itimer-list))
  312.  
  313. ;; User level functions to list and modify existing itimers.
  314. ;; Itimer Edit major mode, and the editing commands thereof.
  315.  
  316. (defun list-itimers ()
  317.   "Pop up a buffer containing a list of all itimers.
  318. The major mode of the buffer is Itimer Edit mode.  This major mode provides
  319. commands to manipulate itimers; see the documentation for
  320. `itimer-edit-mode' for more information."
  321.   (interactive)
  322.   (let* ((buf (get-buffer-create "*Itimer List*"))
  323.      (opoint (point))
  324.      (standard-output buf)
  325.      (itimers (reverse itimer-list)))
  326.     (set-buffer buf)
  327.     (itimer-edit-mode)
  328.     (setq buffer-read-only nil)
  329.     (erase-buffer)
  330.     (insert "Name                  Value     Restart   Function\n"
  331.         "----                  -----     -------   --------")
  332.     (if (null itimer-edit-start-marker)
  333.     (setq itimer-edit-start-marker (point)))
  334.     (while itimers
  335.       (newline 1)
  336.       (prin1 (itimer-name (car itimers)))
  337.       (tab-to-tab-stop)
  338.       (prin1 (itimer-value (car itimers)))
  339.       (tab-to-tab-stop)
  340.       (prin1 (itimer-restart (car itimers)))
  341.       (tab-to-tab-stop)
  342.       (prin1 (itimer-function (car itimers)))
  343.       (setq itimers (cdr itimers)))
  344.     ;; restore point
  345.     (goto-char opoint)
  346.     (if (< (point) itimer-edit-start-marker)
  347.     (goto-char itimer-edit-start-marker))
  348.     (setq buffer-read-only t)
  349.     (display-buffer buf)))
  350.  
  351. (defun edit-itimers ()
  352.   "Display a list of all itimers and select it for editing.
  353. The major mode of the buffer containing the listing is Itimer Edit mode.
  354. This major mode provides commands to manipulate itimers; see the documentation
  355. for `itimer-edit-mode' for more information."
  356.   (interactive)
  357.   ;; since user is editing, make sure displayed data is reasonably up-to-date
  358. ;  (if itimer-process
  359. ;      (itimer-process-wakeup))
  360.   (list-itimers)
  361.   (select-window (get-buffer-window "*Itimer List*"))
  362.   (goto-char itimer-edit-start-marker)
  363.   (if itimer-list
  364.       (progn
  365.     (forward-sexp 2)
  366.     (backward-sexp)))
  367.   (message "type q to quit, ? for help"))
  368.  
  369. ;; no point in making this interactive.
  370. (defun itimer-edit-mode ()
  371.   "Major mode for manipulating itimers.
  372. Atrributes of running itimers are changed by moving the cursor to the
  373. desired field and typing `s' to set that field.  The field will then be
  374. set to the value read from the minibuffer.
  375.  
  376. Commands:
  377. TAB    move forward a field
  378. DEL    move backward a field
  379. s      set a field
  380. d      delete the selected itimer
  381. x      start a new itimer
  382. ?      help"
  383.   (kill-all-local-variables)
  384.   (make-local-variable 'tab-stop-list)
  385.   (setq major-mode 'itimer-edit-mode
  386.     mode-name "Itimer Edit"
  387.     truncate-lines t
  388.     tab-stop-list '(22 32 42))
  389.   (abbrev-mode 0)
  390.   (auto-fill-mode 0)
  391.   (buffer-disable-undo (current-buffer))
  392.   (use-local-map itimer-edit-map)
  393.   (and lisp-mode-syntax-table (set-syntax-table lisp-mode-syntax-table)))
  394.  
  395. (put 'itimer-edit-mode 'mode-class 'special)
  396.  
  397. (defun itimer-edit-help ()
  398.   "Help function for Itimer Edit."
  399.   (interactive)
  400.   (if (eq last-command 'itimer-edit-help)
  401.       (describe-mode)
  402.     (message "TAB, DEL select fields, (s)et field, (d)elete itimer   (type ? for more help)")))
  403.  
  404. (defun itimer-edit-quit ()
  405.   "End Itimer Edit."
  406.   (interactive)
  407.   (bury-buffer (current-buffer))
  408.   (if (one-window-p t)
  409.       (switch-to-buffer (other-buffer (current-buffer)))
  410.     (delete-window)))
  411.  
  412. (defun itimer-edit-set-field ()
  413.   (interactive)
  414.   ;; First two lines in list buffer are headers.
  415.   ;; Cry out against the luser who attempts to change a field there.
  416.   (if (<= (point) itimer-edit-start-marker)
  417.       (error ""))
  418.   ;; field-value must be initialized to be something other than a
  419.   ;; number, symbol, or list.
  420.   (let (itimer field (field-value ""))
  421.     (setq itimer (save-excursion
  422.           ;; read the name of the itimer from the beginning of
  423.           ;; the current line.
  424.           (beginning-of-line)
  425.           (get-itimer (read (current-buffer))))
  426.       field (save-excursion
  427.           (itimer-edit-beginning-of-field)
  428.           (let ((opoint (point))
  429.             (n 0))
  430.             ;; count the number of sexprs until we reach the cursor
  431.             ;; and use this info to determine which field the user
  432.             ;; wants to modify.
  433.             (beginning-of-line)
  434.             (while (and (>= opoint (point)) (< n 4))
  435.               (forward-sexp 2)
  436.               (backward-sexp)
  437.               (itimer-incf n))
  438.             (cond ((eq n 1) (error "Cannot change itimer name."))
  439.               ((eq n 2) 'value)
  440.               ((eq n 3) 'restart)
  441.               ((eq n 4) 'function)))))
  442.     (cond ((eq field 'value)
  443.        ;; XEmacs: rewritten for I18N3 snarfing
  444.        (while (not (natnump field-value))
  445.          (setq field-value (read-from-minibuffer "Set itimer value: "
  446.                              nil nil t))))
  447.       ((eq field 'restart)
  448.        (while (and field-value (not (natnump field-value)))
  449.          (setq field-value (read-from-minibuffer "Set itimer restart: "
  450.                              nil nil t))))
  451.       ((eq field 'function)
  452.        (while (not (or (and (symbolp field-value) (fboundp field-value))
  453.                (and (consp field-value)
  454.                 (memq (car field-value) '(lambda macro)))))
  455.          (setq field-value
  456.            (read (completing-read "Set itimer function: "
  457.                       obarray 'fboundp nil))))))
  458.     ;; set the itimer field
  459.     (funcall (intern (concat "set-itimer-" (symbol-name field)))
  460.          itimer field-value)
  461.     ;; move to beginning of field to be changed
  462.     (itimer-edit-beginning-of-field)
  463.     ;; modify the list buffer to reflect the change.
  464.     (let (buffer-read-only kill-ring)
  465.       (kill-sexp 1)
  466.       (kill-region (point) (progn (skip-chars-forward " \t") (point)))
  467.       (prin1 field-value (current-buffer))
  468.       (if (not (eolp))
  469.       (tab-to-tab-stop))
  470.       (backward-sexp))))
  471.  
  472. (defun itimer-edit-delete-itimer ()
  473.   (interactive)
  474.   ;; First two lines in list buffer are headers.
  475.   ;; Cry out against the luser who attempts to change a field there.
  476.   (if (<= (point) itimer-edit-start-marker)
  477.       (error ""))
  478.   (delete-itimer
  479.    (read-itimer "Delete itimer: "
  480.            (save-excursion (beginning-of-line) (read (current-buffer)))))
  481.   ;; update list information
  482.   (list-itimers))
  483.  
  484. (defun itimer-edit-next-field (count)
  485.   (interactive "p")
  486.   (itimer-edit-beginning-of-field)
  487.   (cond ((> (itimer-signum count) 0)
  488.      (while (not (zerop count))
  489.        (forward-sexp)
  490.        ;; wrap from eob to itimer-edit-start-marker
  491.        (if (eobp)
  492.            (progn
  493.          (goto-char itimer-edit-start-marker)
  494.          (forward-sexp)))
  495.        (forward-sexp)
  496.        (backward-sexp)
  497.        ;; treat fields at beginning of line as if they weren't there.
  498.        (if (bolp)
  499.            (progn
  500.          (forward-sexp 2)
  501.          (backward-sexp)))
  502.        (itimer-decf count)))
  503.     ((< (itimer-signum count) 0)
  504.      (while (not (zerop count))
  505.        (backward-sexp)
  506.        ;; treat fields at beginning of line as if they weren't there.
  507.        (if (bolp)
  508.            (backward-sexp))
  509.        ;; wrap from itimer-edit-start-marker to field at eob.
  510.        (if (<= (point) itimer-edit-start-marker)
  511.            (progn
  512.          (goto-char (point-max))
  513.          (backward-sexp)))
  514.        (itimer-incf count)))))
  515.  
  516. (defun itimer-edit-previous-field (count)
  517.   (interactive "p")
  518.   (itimer-edit-next-field (- count)))
  519.  
  520. (defun itimer-edit-beginning-of-field ()
  521.   (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point)))
  522.     (back (save-excursion (backward-sexp) (point))))
  523.     (cond ((eq forw-back back) (backward-sexp))
  524.       ((eq forw-back (point)) t)
  525.       (t (backward-sexp)))))
  526.  
  527.  
  528. ;; internals of the itimer implementation.
  529.  
  530. (defun itimer-process-filter (process string)
  531.   (error "itimer-process-filter is not used in XEmacs")
  532. ;  ;; If the itimer process dies and generates output while doing
  533. ;  ;; so, we may be called before the process-sentinel.  Sanity
  534. ;  ;; check the output just in case...
  535. ;  (if (not (string-match "^[0-9]" string))
  536. ;      (progn (message "itimer process gave odd output: %s" string)
  537. ;         ;; it may be still alive and waiting for input
  538. ;         (process-send-string itimer-process "3\n"))
  539. ;    ;; if there are no active itimers, return quickly.
  540. ;    (if itimer-list
  541. ;    (let ((time-elapsed (string-to-int string))
  542. ;          (itimers itimer-list)
  543. ;          (itimer)
  544. ;          ;; process filters can be hit by stray C-g's from the user,
  545. ;          ;; so we must protect this stuff appropriately.
  546. ;          ;; Quit's are allowed from within itimer functions, but we
  547. ;          ;; catch them.
  548. ;          (inhibit-quit t))
  549. ;      (setq itimer-process-next-wakeup 600)
  550. ;      (while itimers
  551. ;        (setq itimer (car itimers))
  552. ;        (set-itimer-value itimer (max 0 (- (itimer-value itimer) time-elapsed)) t)
  553. ;        (if (> (itimer-value itimer) 0)
  554. ;        (setq itimer-process-next-wakeup
  555. ;              (min itimer-process-next-wakeup (itimer-value itimer)))
  556. ;          ;; itimer has expired, we must call its function.
  557. ;          ;; protect our local vars from the itimer function.
  558. ;          ;; allow keyboard quit to occur, but catch and report it.
  559. ;          ;; provide the variable `current-itimer' in case the function
  560. ;          ;; is interested.
  561. ;          (condition-case condition-data
  562. ;          (let* ((current-itimer itimer)
  563. ;             itimer itimers time-elapsed
  564. ;             quit-flag inhibit-quit)
  565. ;            (funcall (itimer-function current-itimer)))
  566. ;        (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer)
  567. ;                (prin1-to-string condition-data)))
  568. ;        (quit (message "itimer \"%s\" quit" (itimer-name itimer))))
  569. ;          ;; restart the itimer if we should, otherwise delete it.
  570. ;          (if (null (itimer-restart itimer))
  571. ;          (delete-itimer itimer)
  572. ;        (set-itimer-value itimer (itimer-restart itimer) t)
  573. ;        (setq itimer-process-next-wakeup
  574. ;              (min itimer-process-next-wakeup (itimer-value itimer)))))
  575. ;        (setq itimers (cdr itimers)))
  576. ;      ;; if user is editing itimers, update displayed info
  577. ;      (if (eq major-mode 'itimer-edit-mode)
  578. ;          (list-itimers)))
  579. ;      (setq itimer-process-next-wakeup 600))
  580. ;    ;; tell itimer-process when to wakeup again
  581. ;    (process-send-string itimer-process
  582. ;             (concat (int-to-string itimer-process-next-wakeup)
  583. ;                 "\n")))
  584.   )
  585.  
  586. (defun itimer-process-sentinel (process message)
  587.   (error "itimer-process-sentinel is not used in XEmacs")
  588. ;  (let ((inhibit-quit t))
  589. ;    (if (eq (process-status process) 'stop)
  590. ;    (continue-process process)
  591. ;      ;; not stopped, so it must have died.
  592. ;      ;; cleanup first...
  593. ;      (delete-process process)
  594. ;      (setq itimer-process nil)
  595. ;      ;; now, if there are any active itimers then we need to immediately
  596. ;      ;; start another itimer process, otherwise we can wait until the next
  597. ;      ;; start-itimer call,  which will start one automatically.
  598. ;      (if (null itimer-list)
  599. ;      ()
  600. ;    ;; there may have been an error message in the echo area;
  601. ;    ;; give the user at least a little time to read it.
  602. ;    (sit-for 2)
  603. ;    (message "itimer process %s... respawning." (substring message 0 -1))
  604. ;    (itimer-process-start))))
  605.   )
  606.  
  607. (defun itimer-process-start ()
  608.   (error "itimer-process-start is not used in XEmacs")
  609. ;  (let ((inhibit-quit t)
  610. ;    (process-connection-type nil))
  611. ;    (setq itimer-process (start-process "itimer" nil "itimer"))
  612. ;    (process-kill-without-query itimer-process)
  613. ;    (set-process-filter itimer-process 'itimer-process-filter)
  614. ;    (set-process-sentinel itimer-process 'itimer-process-sentinel)
  615. ;    ;; Tell itimer process to wake up quickly, so that a correct wakeup
  616. ;    ;; time can be computed.  Zero instead of one here loses because of
  617. ;    ;; underlying itimer implementations that use 0 to mean `disable the
  618. ;    ;; itimer'.
  619. ;    (setq itimer-process-next-wakeup 1)
  620. ;    (process-send-string itimer-process "1\n"))
  621.   )
  622.  
  623. (defun itimer-process-wakeup ()
  624.   (error "itimer-process-wakeup is not used in XEmacs")
  625. ;  (interrupt-process itimer-process)
  626. ;  (accept-process-output)
  627.   )
  628.  
  629.  
  630. ;; XEmacs-specific code
  631.  
  632. (defun activate-itimer (itimer)
  633.   (let ((inhibit-quit t))
  634.     (set-itimer-id itimer
  635.           (add-timeout (itimer-value itimer)
  636.                    'itimer-callback
  637.                    itimer
  638.                    (itimer-restart itimer))))
  639.   itimer)
  640.  
  641. (defun deactivate-itimer (itimer)
  642.   (let ((inhibit-quit t)
  643.     (id (itimer-id itimer)))
  644.     (and id (disable-timeout id))
  645.     (set-itimer-id itimer nil))
  646.   itimer)
  647.  
  648. (defun itimer-callback (current-itimer)
  649.   (funcall (itimer-function current-itimer)))
  650.  
  651.  
  652. ;;; itimer-driven auto-saves
  653.  
  654. ;jwz: this is preloaded so don't ;;;###autoload
  655. (defvar auto-save-timeout 30
  656.   "*Number of seconds idle time before auto-save.
  657. Zero or nil means disable auto-saving due to idleness.
  658.  
  659. The actual amount of idle time between auto-saves is logarithmically related
  660. to the size of the current buffer.  This variable is the number of seconds
  661. after which an auto-save will happen when the current buffer is 50k or less;
  662. the timeout will be 2 1/4 times this in a 200k buffer, 3 3/4 times this in a
  663. 1000k buffer, and 4 1/2 times this in a 2000k buffer.
  664.  
  665. See also the variable `auto-save-interval', which controls auto-saving based
  666. on the number of characters typed.")
  667.  
  668. ;jwz: this is preloaded so don't ;;;###autoload
  669. (defvar auto-gc-threshold (/ gc-cons-threshold 3)
  670.   "*GC when this many bytes have been consed since the last GC, 
  671. and the user has been idle for `auto-save-timeout' seconds.")
  672.  
  673. (defun auto-save-itimer ()
  674.   "For use as a itimer callback function.
  675. Auto-saves and garbage-collects based on the size of the current buffer
  676. and the value of `auto-save-timeout', `auto-gc-threshold', and the current
  677. keyboard idle-time."
  678.   (if (or (null auto-save-timeout)
  679.       (<= auto-save-timeout 0)
  680.       (eq (minibuffer-window) (selected-window)))
  681.       nil
  682.     (let ((buf-size (1+ (ash (buffer-size) -8)))
  683.       (delay-level 0)
  684.       (now (current-time))
  685.       delay)
  686.       (while (> buf-size 64)
  687.     (setq delay-level (1+ delay-level)
  688.           buf-size (- buf-size (ash buf-size -2))))
  689.       (if (< delay-level 4)
  690.       (setq delay-level 4))
  691.       ;; delay_level is 4 for files under around 50k, 7 at 100k, 9 at 200k,
  692.       ;; 11 at 300k, and 12 at 500k, 15 at 1 meg, and 17 at 2 meg.
  693.       (setq delay (/ (* delay-level auto-save-timeout) 4))
  694.       (let ((idle-time (if (or (not (consp last-input-time))
  695.                    (/= (car now) (car last-input-time)))
  696.                (1+ delay)
  697.              (- (car (cdr now)) (cdr last-input-time)))))
  698.     (and (> idle-time delay)
  699.          (do-auto-save))
  700.     (and (> idle-time auto-save-timeout)
  701.          (> (consing-since-gc) auto-gc-threshold)
  702.          (garbage-collect)))))
  703.   ;; Look at the itimer that's currently running; if the user has changed
  704.   ;; the value of auto-save-timeout, modify this itimer to have the correct
  705.   ;; restart time.  There will be some latency between when the user changes
  706.   ;; this variable and when it takes effect, but it will happen eventually.
  707.   (let ((self (get-itimer "auto-save")))
  708.     (or self (error "auto-save-itimer can't find itself"))
  709.     (if (and auto-save-timeout (> auto-save-timeout 4))
  710.     (or (= (itimer-restart self) (/ auto-save-timeout 4))
  711.         (set-itimer-restart self (/ auto-save-timeout 4)))))
  712.   nil)
  713.  
  714. (defun itimer-init-auto-gc ()
  715.   (or noninteractive ; may be being run from after-init-hook in -batch mode.
  716.       (get-itimer "auto-save")
  717.       ;; the time here is just the first interval; if the user changes it
  718.       ;; later, it will adjust.
  719.       (let ((time (max 2 (/ (or auto-save-timeout 30) 4))))
  720.     (start-itimer "auto-save" 'auto-save-itimer time time))))
  721.  
  722. (cond (purify-flag
  723.        ;; This file is being preloaded into an emacs about to be dumped.
  724.        ;; So arrange for the auto-save itimer to be started once emacs
  725.        ;; is launched.
  726.        (add-hook 'after-init-hook 'itimer-init-auto-gc))
  727.       (t
  728.        ;; Otherwise, this file is being loaded into a normal, interactive
  729.        ;; emacs.  Start the auto-save timer now.
  730.        (itimer-init-auto-gc)))
  731.  
  732.  
  733. (provide 'itimer)
  734.